home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / env.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-23  |  5.4 KB  |  220 lines
  1. /*
  2.  *
  3.  * e n v . c            -- Environment management
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 23-Oct-1993 21:37
  22.  * Last file update: 23-Jul-1996 15:44
  23.  */
  24.  
  25. #include "stk.h"
  26. #include "extend.h"
  27.  
  28. static void makelocalvar(SCM x, int level, int position)
  29. {
  30.   if (ModifyCode() && CONSP(x)) { /* Replace (CAR x) by a localvar access */
  31.     SCM z;
  32.     NEWCELL(z, tc_localvar);
  33.     z->storage_as.localvar.position = position;
  34.     z->storage_as.localvar.level    = level;
  35.     z->storage_as.localvar.symbol   = CAR(x);
  36.     CAR(x) = z;
  37.   }
  38. }
  39.  
  40. static void makeglobalvar(SCM x)
  41. {
  42.   if (ModifyCode() && CONSP(x)) { /* Replace (CAR x) by a globalvar access */
  43.     SCM z;
  44.     NEWCELL(z, tc_globalvar);
  45.     VCELL(z) = CAR(x);
  46.     CAR(x) = z;
  47.   }
  48. }
  49.  
  50. SCM STk_makeenv(SCM l, int create_if_null)
  51. {
  52.   SCM z;
  53.   
  54.   if (NULLP(l) && !create_if_null) return STk_globenv;
  55.   
  56.   NEWCELL(z, tc_env);
  57.   z->storage_as.env.data = l;
  58.   return z;
  59. }
  60.  
  61. /* Return the value of var in given env. Search is done only at out most level */
  62. SCM *STk_value_in_env(SCM var, SCM env)
  63. {
  64.   SCM fl, *al;
  65.   
  66.   al = &CAR(env);
  67.   for (fl=CAR(CAR(env)); NNULLP(fl); fl=CDR(fl)) {
  68.     if (NCONSP(fl)) {
  69.       if (EQ(fl, var)) return &CDR(*al);
  70.       else break;
  71.     }
  72.     al = &CDR(*al);
  73.     if EQ(CAR(fl), var) return &CAR(*al);
  74.   }
  75.   /* Not found */
  76.   return &UNBOUND;
  77. }
  78.  
  79. SCM *STk_varlookup(SCM x, SCM env, int err_if_unbound)
  80. {
  81.   SCM frame, fl, *al, var;
  82.   int level, pos;
  83.  
  84.   var = CONSP(x)? CAR(x) : x;
  85.  
  86.   /* Try to find var in env */ 
  87.   for(level=0, frame=env; CONSP(frame); frame=CDR(frame), level++) {
  88.     al = &CAR(frame);
  89.  
  90.     for (pos=0, fl=CAR(CAR(frame)); NNULLP(fl); fl=CDR(fl), pos++) {
  91.       if (NCONSP(fl)) {
  92.     if (EQ(fl, var)) { makelocalvar(x, level, pos); return &CDR(*al); }
  93.     else break;
  94.       }
  95.       al = &CDR(*al);
  96.       if EQ(CAR(fl), var) { makelocalvar(x, level, pos); return &CAR(*al); }
  97.     }
  98.   }
  99.   /* Not found. Return it's value in global environment */
  100.   if (err_if_unbound) {
  101.     SCM val = VCELL(var);
  102.  
  103.     if (val == UNBOUND) {
  104.       /* C variables are always seen as unbound variables. This tends to 
  105.        * make them slower than standard variables but, in counterpart, this
  106.        * doesn't slow down acceses to Scheme variable 
  107.        */
  108.       if (var->cell_info & CELL_INFO_C_VAR) {
  109.     /* This is not an unbound variable but rather a C variable */
  110.     static SCM tmp;
  111.     tmp = STk_apply_getter_C_variable(PNAME(var));
  112.     return &tmp;
  113.       }
  114.       Err("unbound variable", var);
  115.     }
  116.     if (TYPEP(val, tc_autoload)) STk_do_autoload(var);
  117.   }
  118.   makeglobalvar(x);
  119.   return &VCELL(var);
  120. }
  121.  
  122. SCM STk_localvalue(SCM var, SCM env)
  123. {
  124.   register SCM p, q;
  125.   register int i;
  126.  
  127.   p = env;
  128.   /* Go down ``level'' environments */
  129.   for (i = var->storage_as.localvar.level; i; i--)
  130.     p = CDR(p);
  131.   
  132.   /* Go forward ``position'' variables */
  133.   q = CAR(CAR(p)); p = CDR(CAR(p)); 
  134.   for (i = var->storage_as.localvar.position; i; i--) {
  135.     p = CDR(p);
  136.     q = CDR(q);
  137.   }
  138.   return CONSP(q) ? CAR(p) : p;
  139. }
  140.  
  141.  
  142. SCM STk_extend_env(SCM formals, SCM actuals, SCM env, SCM who)
  143. {
  144.   register SCM f = formals, a = actuals;
  145.  
  146.   for ( ; NNULLP(f); f=CDR(f), a=CDR(a)) {
  147.     if (NCONSP(f)) goto Out;
  148.     if (NULLP(a)) Err("too few arguments to", who);
  149.   }
  150.   if (NNULLP(a)) Err("too many arguments to", who);
  151.  Out:
  152.   return STk_fast_extend_env(formals, actuals, env);
  153. }
  154.  
  155.  
  156.  
  157. PRIMITIVE STk_symbol_boundp(SCM x, SCM env)
  158. {
  159.   SCM tmp;
  160.  
  161.   if (NSYMBOLP(x)) Err("symbol-bound?: not a symbol", x);
  162.   if (env == UNBOUND) env = STk_globenv;
  163.   else 
  164.     if (NENVP(env)) Err("symbol-bound?: bad environment", env);
  165.  
  166.   tmp = *STk_varlookup(x, env->storage_as.env.data, FALSE);
  167.   return (tmp == UNBOUND) ? Ntruth : Truth;
  168. }
  169.  
  170. PRIMITIVE STk_the_environment(SCM args, SCM env, int len)
  171. {
  172.   if (len) Err("the-environement: Too much parameters", args);
  173.   return STk_makeenv(env, 0);
  174. }
  175.  
  176. PRIMITIVE STk_parent_environment(SCM env)
  177. {
  178.   if (NENVP(env)) Err("parent->environment: bad environment", env);
  179.  
  180.   return (env==STk_globenv) ? Ntruth: STk_makeenv(CDR(env->storage_as.env.data),0);
  181. }
  182.  
  183. PRIMITIVE STk_global_environment(void)
  184. {
  185.   return STk_globenv;
  186. }
  187.  
  188. static SCM local_env2list(SCM l)
  189. {
  190.   register SCM res=NIL, l1, l2;
  191.  
  192.   for (l1=CAR(l), l2=CDR(l); NNULLP(l1); l1=CDR(l1), l2=CDR(l2))
  193.     if (CONSP(l1))
  194.       res = Cons(Cons(CAR(l1), CAR(l2)), res);
  195.     else
  196.       /* We had a dotted list */
  197.       return  Cons(Cons(l1, l2), res);
  198.   return res;
  199. }
  200.  
  201.  
  202. PRIMITIVE STk_environment2list(SCM env)
  203. {
  204.   SCM l, res = NIL;
  205.  
  206.   if (NENVP(env)) Err("environment->list: bad environment", env);
  207.  
  208.   for (l=env->storage_as.env.data; NNULLP(l); l=CDR(l))
  209.     res = Cons(local_env2list(CAR(l)), res);
  210.   
  211.   res = Cons(STk_global_env2list(), res);
  212.   return Reverse(res);
  213. }
  214.  
  215.  
  216. PRIMITIVE STk_environmentp(SCM obj)
  217. {
  218.   return ENVP(obj)? Truth: Ntruth;
  219. }
  220.